home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / maincase.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  22.4 KB  |  877 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "ops.h"
  16. #include "segment.h"
  17. #include "dbxprots.h"
  18. #include "namprots.h"
  19. #include "procprots.h"
  20. #include "exprprots.h"
  21. #include "setprots.h"
  22. #include "genprots.h"
  23. #include "statprots.h"
  24. #include "miscprots.h"
  25. #include "gmiscprots.h"
  26. #include "smiscprots.h"
  27. #include "segmentprots.h"
  28. #include "declprots.h"
  29. #include "typeprots.h"
  30. #include "packprots.h"
  31. #include "gutilprots.h"
  32. #include "axqrprots.h"
  33. #include "sepprots.h"
  34. #include "maincaseprots.h"
  35.  
  36. static void compile_line();
  37.  
  38. void compile(Node node)                                            /*;compile*/
  39. {
  40.     /* Generates one TREE statement */
  41.  
  42.     Node     expr_node;
  43.     Symbol    junk_var;
  44.     Tuple    case_table;
  45.     Tuple    tup;
  46.     Const    cond_val;
  47.     Tuple    labtup;
  48.     int        lablev;
  49.  
  50.     Node    
  51.       pre_node, post_node, decl_node, id_list_node, type_node, init_node,
  52.       stmt_node, var_node, exp_node, if_list_node, else_node, cond_node,
  53.       body_node, cases_node, id_node, stmts_node, handler_node, proc_node,
  54.       args_node, obj_node, package_tasks_node,
  55.       entry_node, alt_node, acc_node, delay_node, call_node, stmts1_node,
  56.       stmts2_node, task_node, separate_unit_node, label_node, others_node,
  57.       n, temp_node;
  58.     Tuple   condition_list, id_list, task_list, select_list, case_bodies;
  59.     Symbol   label_name, type_name, proc_name, new_name, old_name, entry_name,
  60.       exception_name, package_tasks_name, else_part, dont_exit, end_if,
  61.       true_guard, end_alt, i_subt;
  62.     Tuple   except_names, predef_tuple;
  63.     Tuple        labs;
  64.     int        nesting_depth, lineno, flag, tag, i;
  65.     int        guarded;
  66.     /* DECL */
  67.     Fortup    ft1;
  68.     int         function_code;
  69.     Const    ival;
  70.     int        ikind;
  71.     Segment    init_val;
  72.  
  73. #ifdef TRACE
  74.     if (debug_flag)
  75.         gen_trace_node("COMPILE", node);
  76. #endif
  77.  
  78. #ifdef DEBUG
  79.     if (trapns>0 && N_SEQ(node) == trapns && N_UNIT(node) == trapnu)trapn(node);
  80. #endif
  81.     switch(N_KIND(node)) {
  82.  
  83.     case(as_opt):          /* OPT_NODE */
  84.         break;
  85.  
  86.     case(as_deleted):      /* Deleted by expander */
  87.         break;
  88.  
  89.     case(as_insert):       /* Inserted by expander */
  90.         FORTUP(pre_node=(Node), N_LIST(node), ft1);
  91.             compile(pre_node);
  92.         ENDFORTUP(ft1);
  93.         post_node = N_AST1(node);
  94.         compile(post_node);
  95.         break;
  96.  
  97.     case(as_discard):     /* Some check to evaluate and discard */
  98.         expr_node = N_AST1(node);
  99.         junk_var    = new_unique_name("junk"); /* TBSL: Reusing same variable */
  100.         next_local_reference(junk_var);
  101.         gen_ks(I_DECLARE, kind_of(N_TYPE(node)), junk_var);
  102.  
  103.         gen_value(expr_node);
  104.         gen_ksc(I_POP, kind_of(N_TYPE(node)), junk_var, "Used only for check");
  105.         break;
  106.  
  107.     /* Chapter 2. Lexical elements
  108.      *------------
  109.      * 2.8 Pragmas
  110.      */
  111.     case(as_pragma):       /*TBSL(JC)    pragmas */
  112.         break;
  113.  
  114.     case(as_arg):          /*TBSL(JC)    arguments for pragmas */
  115.         break;
  116.  
  117.     /* Chapter 3. Declarations and types */
  118.     case(as_labels):
  119.         break;
  120.  
  121.     /* 3.1 Declarations */
  122.     case(as_declarations):
  123.         FORTUP(decl_node=(Node), N_LIST(node), ft1);
  124.             compile(decl_node);
  125.         ENDFORTUP(ft1);
  126.         break;
  127.  
  128.     /* 3.2 Objects and named numbers */
  129.     case(as_const_decl):
  130.         id_list_node = N_AST1(node);
  131.         type_node = N_AST2(node);
  132.         init_node = N_AST3(node);
  133.  
  134.         /* Generate pre-statements */
  135.         while (N_KIND(init_node) == as_insert) {
  136.             FORTUP(pre_node=(Node), N_LIST(init_node), ft1);
  137.                 compile(pre_node);
  138.             ENDFORTUP(ft1);
  139.             init_node = N_AST1(init_node);
  140.         }
  141.  
  142.         id_list   = N_LIST(id_list_node);
  143.         type_name = N_UNQ(type_node);
  144.         create_object(id_list, type_name, init_node, TRUE);
  145.  
  146.         TASKS_DECLARED |= (int) CONTAINS_TASK(type_name);
  147.         break;
  148.  
  149.     case(as_obj_decl):
  150.         id_list_node = N_AST1(node);
  151.         type_node = N_AST2(node);
  152.         init_node = N_AST3(node);
  153.  
  154.         /* Generate pre-statements */
  155.         while (N_KIND(init_node) == as_insert) {
  156.             FORTUP(pre_node=(Node), N_LIST(init_node), ft1);
  157.                 compile(pre_node);
  158.             ENDFORTUP(ft1);
  159.             init_node = N_AST1(init_node);
  160.         }
  161.  
  162.         id_list   = N_LIST(id_list_node);
  163.         type_name = N_UNQ(type_node);
  164.         create_object(id_list, type_name, init_node, FALSE);
  165.  
  166.         TASKS_DECLARED |= (int)CONTAINS_TASK(type_name);
  167.         break;
  168.  
  169.     case(as_num_decl):
  170.         break;
  171.  
  172.     /* 3.3 Types and subtypes */
  173.     case(as_type_decl):
  174.         id_node = N_AST1(node);
  175.         type_name = N_UNQ(id_node);
  176.         gen_type(type_name);
  177.         break;
  178.  
  179.     case(as_subtype_decl):
  180.         id_node = N_AST1(node);
  181.         type_name = N_UNQ(id_node);
  182.         gen_subtype(type_name);
  183.         break;
  184.  
  185.     /* Chapter 5. Statements */
  186.     case(as_null_s):
  187.         break;
  188.  
  189.     case(as_line_no):
  190.         NB_STATEMENTS += 1;
  191.         lineno = (int) N_VAL(node);
  192.         ada_line = lineno;
  193. #ifdef MACHINE_CODE
  194.         if (debug_line > 0 && lineno >= debug_line)
  195.             compile_line();
  196. #endif
  197.         if (line_option)
  198.             gen_i(I_STMT, lineno);
  199.         break;
  200.  
  201.     /* 5.1 Simple and compound statements */
  202.     case(as_statements):
  203.         stmts_node = N_AST1(node);
  204.         label_node = N_AST2(node);
  205.         labs = tup_new(0);
  206.         FORTUP(n=(Node), N_LIST(label_node), ft1);
  207.             if (!tup_mem((char *) N_UNQ(n), labs))
  208.                 labs =tup_with(labs, (char *)N_UNQ(n));
  209.         ENDFORTUP(ft1);
  210.         FORTUP(label_name=(Symbol), labs, ft1);
  211.             labelmap_put(label_name, LABEL_STATIC_DEPTH, (char *)CURRENT_LEVEL);
  212.             next_local_reference(label_name);
  213.             gen_s(I_SAVE_STACK_POINTER, label_name);
  214.         ENDFORTUP(ft1);
  215.         FORTUP(stmt_node=(Node), N_LIST(stmts_node), ft1);
  216.             compile(stmt_node);
  217.         ENDFORTUP(ft1);
  218.         tup_free(labs);
  219.         break;
  220.  
  221.     case(as_statement):
  222.         label_node = N_AST1(node);
  223.         stmt_node = N_AST2(node);
  224.         labs = tup_new(0);
  225.         FORTUP(n=(Node), N_LIST(label_node), ft1);
  226.             if (!tup_mem((char *) N_UNQ(n), labs))
  227.                 labs =tup_with(labs, (char *) N_UNQ(n));
  228.         ENDFORTUP(ft1);
  229.         FORTUP(label_name=(Symbol), labs, ft1);
  230.             gen_s(I_LABEL, label_name);
  231.         ENDFORTUP(ft1);
  232.         compile(stmt_node);
  233.         tup_free(labs);
  234.         break;
  235.  
  236.     /* 5.2 Assignment statement */
  237.     case(as_assignment): 
  238.     case(as_static_comp):
  239.         var_node = N_AST1(node);
  240.         exp_node = N_AST2(node);
  241.         type_name           = get_type(var_node);
  242.         select_assign(var_node, exp_node, type_name);
  243.         break;
  244.  
  245.     /*  5.3 If statement */
  246.     case(as_if):
  247.         if_list_node = N_AST1(node);
  248.         else_node = N_AST2(node);
  249.         end_if = new_unique_name("end_if");
  250.         condition_list  = tup_copy(N_LIST(if_list_node));
  251.         /* tup_copy needed since condition_list used in tup_fromb below */
  252.         while (tup_size(condition_list)) {
  253.             n = (Node) tup_fromb(condition_list);
  254.             cond_node = N_AST1(n);
  255.             body_node = N_AST2(n);
  256.             else_part = new_unique_name("else");
  257.             gen_condition(cond_node, else_part, FALSE);
  258.             compile(body_node);
  259.             if ((tup_size(condition_list) != 0) || (else_node != OPT_NODE))
  260.                 gen_s(I_JUMP, end_if);
  261.             gen_s(I_LABEL, else_part);
  262.         }
  263.  
  264.         if (else_node != OPT_NODE)
  265.             compile(else_node);
  266.  
  267.         gen_s(I_LABEL, end_if);
  268.         break;
  269.  
  270.     /* 5.4 Case statements */
  271.     case(as_case):
  272.         exp_node = N_AST1(node);
  273.         cases_node = N_AST2(node);
  274.         gen_value(exp_node);
  275.         tup = make_case_table(cases_node);
  276.         case_table = (Tuple) tup[1];
  277.         case_bodies = (Tuple) tup[2];
  278.         others_node = (Node) tup[3];
  279.         gen_case(case_table, case_bodies, others_node,
  280.           kind_of(get_type(exp_node)));
  281.         break;
  282.  
  283.     /* 5.5 Loop statements */
  284.     case(as_loop):
  285.         gen_loop(node);
  286.         break;
  287.  
  288.     /* 5.6 Block statements */
  289.     case(as_block):
  290.         id_node = N_AST1(node);
  291.         decl_node = N_AST2(node);
  292.         stmts_node = N_AST3(node);
  293.         handler_node = N_AST4(node);
  294.         compile_body(decl_node, stmts_node, handler_node, TRUE);
  295.         break;
  296.  
  297.     case(as_end):
  298.         gen(I_EXIT_BLOCK);
  299.         break;
  300.  
  301.     /* 5.7 Exit statements */
  302.     case(as_exit):
  303.         cond_node = N_AST2(node);
  304.         label_name     = N_UNQ(node);
  305.         if (cond_node != OPT_NODE) {
  306.             dont_exit = new_unique_name("continue");
  307.             gen_condition(cond_node, dont_exit, FALSE);
  308.         }
  309.         labtup = labelmap_get(label_name);
  310.         if (labtup == (Tuple)0)
  311.             chaos("as_exit label map undefined");
  312.         lablev = (int) labtup[LABEL_STATIC_DEPTH];
  313.         for (i = lablev;i<CURRENT_LEVEL; i++)
  314.             gen(I_EXIT_BLOCK);
  315.         gen_s(I_RESTORE_STACK_POINTER, label_name);
  316.         gen_s(I_JUMP, label_name);
  317.         if (cond_node != OPT_NODE)
  318.             gen_s(I_LABEL, dont_exit);
  319.         break;
  320.  
  321.     /* 5.8 Return statements */
  322.     case(as_return):
  323.         exp_node = N_AST1(node);
  324.         id_node = N_AST2(node);
  325.         proc_name           = N_UNQ(id_node);
  326.         nesting_depth       = (int) N_VAL(N_AST3(node));
  327.  
  328.         if (NATURE(proc_name) == na_entry
  329.           || NATURE(proc_name) == na_entry_family) {
  330.             /* Entry return */
  331.             for (i=1; i<=nesting_depth; i++)
  332.                 gen(I_LEAVE_BLOCK);
  333.             /* allocate symbol for return target label if not yet allocated
  334.                * (see comments in gen_accept() for details)
  335.                */
  336.             if (symbol_accept_return == (Symbol)0)
  337.                 symbol_accept_return = new_unique_name("end_handler");
  338.             gen(I_EXIT_BLOCK);
  339.             gen_s(I_JUMP, symbol_accept_return);
  340.         }
  341.         else {
  342.             if ( exp_node != OPT_NODE) {
  343.                 if (N_KIND (exp_node) == as_raise) {
  344.                     /* the result of the function raises an exception */
  345.                     if (N_AST1 (exp_node) != OPT_NODE) {
  346.                         gen_s(I_LOAD_EXCEPTION_REGISTER,
  347.                           N_UNQ(N_AST1(exp_node)));
  348.                     }
  349.                     gen(I_RAISE);
  350.                 }
  351.                 else {
  352.                     /* Function return */
  353.                     gen_value(exp_node);
  354.                     type_name = N_TYPE(exp_node);
  355.                     if (is_simple_type(type_name)) {
  356.                         gen_ks(I_RETURN, kind_of(type_name),
  357.                           assoc_symbol_get(proc_name, RETURN_TEMPLATE));
  358.                     }
  359.                     else {
  360.                         if (is_record_type(type_name)) {
  361.                             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  362.                         }
  363.                         gen_s(I_RETURN_STRUC,
  364.                             assoc_symbol_get(proc_name, RETURN_TEMPLATE));
  365.                     }
  366.                 }
  367.             }
  368.             for (i = 0; i <= nesting_depth; i++) {
  369.                 gen(I_LEAVE_BLOCK);
  370.             }
  371.         }
  372.         break;
  373.  
  374.     /* 5.9 Goto statements */
  375.     case(as_goto):
  376.         id_node  = N_AST1(node);
  377.         label_name = N_UNQ(id_node);
  378.         labtup = labelmap_get(label_name);
  379.         if (labtup == (Tuple)0)
  380.             chaos("as_goto label map undefined");
  381.         lablev = (int) labtup[LABEL_STATIC_DEPTH];
  382.         for (i=lablev; i<CURRENT_LEVEL; i++)
  383.             gen(I_EXIT_BLOCK);
  384.         gen_s(I_RESTORE_STACK_POINTER, label_name);
  385.         gen_s(I_JUMP, label_name);
  386.         break;
  387.  
  388.     /* Chapter 6. Subprograms */
  389.     case(as_predef):
  390.         break;
  391.     case(as_interfaced):
  392.         break;
  393.  
  394.     /* 6.1 Subprogram declarations */
  395.     case(as_subprogram_decl_tr):
  396.         gen_subprogram_spec(node);
  397.         break;
  398.  
  399.     /* 6.3 Subprogram bodies */
  400.     case(as_subprogram_tr):
  401.         gen_subprogram(node);
  402.         break;
  403.  
  404.     /* 6.4 Subprogram calls */
  405.     case(as_call): 
  406.     case(as_init_call):
  407.         proc_node = N_AST1(node);
  408.         args_node = N_AST2(node);
  409.         proc_name              = N_UNQ(proc_node);
  410.         while (is_renaming(proc_name))
  411.             proc_name = ALIAS(proc_name);
  412.         gen_prelude(proc_name, args_node);
  413.  
  414.         /* we must check that this is a real proc, and not some predef stuff */
  415.         predef_tuple = (Tuple) MISC(proc_name);
  416.         if (predef_tuple!=(Tuple)0) {
  417.             /* predefined operation */
  418.             function_code = (int) predef_tuple[1];
  419.             /* the predefined functions are mapped to integers lesser than 256
  420.                * whereas the interfaced procedures are mapped to integers greater
  421.                * than 256
  422.              */
  423.             if (function_code < 255) {
  424.                 type_name = (Symbol) predef_tuple[2];
  425.                 if (type_name != OPT_NAME) {
  426.                     gen_sc(I_PUSH_EFFECTIVE_ADDRESS, type_name,
  427.                       "discarded by predef");
  428.                 }
  429.                 gen_ic(I_CALL_PREDEF, function_code, "predef");
  430.             }
  431.             else {
  432.                 gen_ic(I_CALL_INTERFACE, function_code, "interfaced");
  433.             }
  434.         }
  435.         else {
  436.             gen_s(I_CALL, proc_name);
  437.         }
  438.         gen_postlude(proc_name, args_node);
  439.         break;
  440.  
  441.     /* Chapter 7. Packages
  442.      * 7.2 Package specifications and declarations
  443.      */
  444.     case(as_package_spec):
  445.         gen_package(node);
  446.         break;
  447.  
  448.     /* 7.3 Package bodies */
  449.     case(as_package_body):
  450.         gen_package_body(node);
  451.         break;
  452.  
  453.     /* 7.4 Private type and deferred constant declarations */
  454.     case(as_private_decl):
  455.         break;
  456.  
  457.     /* Chapter 8. Visibility rules */
  458.  
  459.     /* 8.5 Renaming declarations */
  460.     case(as_rename_obj):
  461.         id_node = N_AST1(node);
  462.         type_node = N_AST2(node);
  463.         obj_node = N_AST3(node);
  464.         new_name = N_UNQ(id_node);
  465.  
  466.         if (is_ivalue(obj_node) && is_simple_type(N_UNQ(type_node))) {
  467.                 ival = get_ivalue(obj_node);
  468.                 ikind = ival->const_kind;
  469.                 if(ikind == CONST_INT) {
  470.                     init_val = segment_new(SEGMENT_KIND_DATA, 1);
  471.                     segment_put_word(init_val, ival->const_value.const_int);
  472.                 }
  473.                 else if(ikind == CONST_REAL) {
  474.                     init_val = segment_new(SEGMENT_KIND_DATA, 1);
  475.                     segment_put_real(init_val, ival->const_value.const_real);
  476.                 }
  477.                 else {
  478. #ifdef DEBUG
  479.                     printf("const_kind %d\n", ikind);
  480. #endif        
  481.                     chaos("as_rename_object:unsupported kind");
  482.                 }
  483.                 old_name = get_constant_name(init_val);
  484.                 assign_same_reference(new_name, old_name);
  485.                 if (!is_renaming(old_name)) {
  486.                     ALIAS(new_name) = (Symbol) 0; /* not a renaming any more */
  487.                 }
  488.         }
  489.         else if (is_simple_name(obj_node)) {
  490.             old_name = N_UNQ(obj_node);
  491.             assign_same_reference(new_name, old_name);
  492.             ASSOCIATED_SYMBOLS(new_name) = ASSOCIATED_SYMBOLS(old_name);
  493.             if (TYPE_OF(new_name) != TYPE_OF(old_name))
  494.                 TYPE_OF(new_name) = TYPE_OF(old_name);
  495.             if (!is_renaming(old_name)) {
  496.                 ALIAS(new_name) = (Symbol) 0;     /* not a renaming any more */
  497.             }
  498.         }
  499.         else if (CURRENT_LEVEL > 1) {
  500.             next_local_reference(new_name);
  501.             gen_address(obj_node);
  502.             type_name = get_type(id_node);
  503.             if (is_array_type(type_name)) {
  504.                 if (N_KIND(obj_node) == as_all) {
  505.                     i_subt = new_unique_name("dyn_(sub)type");
  506.                     new_symbol(i_subt,NATURE(type_name),TYPE_OF(type_name),
  507.                         SIGNATURE(type_name), root_type(type_name));
  508.                     gen_type(i_subt);
  509.                     type_name = i_subt;
  510.                     TYPE_OF(N_UNQ(id_node)) = type_name;
  511.                 }
  512.                 /* the address of the type is pushed by gen_address */
  513.                 if (N_KIND(obj_node) == as_slice || N_KIND(obj_node) == as_all) {
  514.                     gen_s(I_UPDATE_AND_DISCARD,type_name);
  515.                 }
  516.                 else {
  517.                     gen_ks(I_DISCARD_ADDR,1,(Symbol)0);
  518.                 }
  519.             }
  520.             gen_s(I_UPDATE_AND_DISCARD, new_name);
  521.         }
  522.         else {
  523.             next_global_reference_r(new_name, 0, 0);
  524.             gen_address(obj_node);
  525.             gen_ks(I_POP, mu_addr, new_name);
  526.         }
  527.         break;
  528.  
  529.     case(as_rename_ex):
  530.         break;
  531.  
  532.     case(as_rename_pack):
  533.         break;
  534.  
  535.     /* Chapter 9. Tasks
  536.      * 9.1 Task specifications and task bodies
  537.      * Task body transformed into procedure by expander
  538.      *------------------------------------------------
  539.      * 9.3 Task Execution - Task Activation
  540.      */
  541.     case(as_activate_spec):        /* used internally only */
  542.         package_tasks_node = N_AST1(node);
  543.         package_tasks_name   = N_UNQ(package_tasks_node);
  544.         gen_ks(I_PUSH, mu_word, package_tasks_name);
  545.         gen(I_LINK_TASKS_DECLARED);
  546.         gen(I_ACTIVATE);
  547.         break;
  548.  
  549.     case(as_end_activation):
  550.         tag = (int) N_VAL(node);
  551.         if (tag == 1)
  552.             gen_ic(I_END_ACTIVATION, tag, "Ok");
  553.         else
  554.             gen_ic(I_END_ACTIVATION, tag, "Failed");
  555.         break;
  556.  
  557.     /* 9.4 Task Dependance - Termination of Tasks */
  558.     case(as_terminate):
  559.         tup = (Tuple) N_VAL(node);
  560.         nesting_depth = (int) tup[1];
  561.         tag = (int) tup[2];
  562.         for (i=1; i<=nesting_depth; i++)
  563.             gen(I_LEAVE_BLOCK);
  564.         gen_i(I_TERMINATE, tag);
  565.         break;
  566.  
  567.     /* 9.5 Entries, entry calls, and accept statements */
  568.     case(as_ecall):
  569.         entry_node = N_AST1(node);
  570.         args_node = N_AST2(node);
  571.         gen_value(entry_node);
  572.         id_node = N_AST2(entry_node);
  573.         entry_name = N_UNQ(id_node);
  574.         gen_prelude(entry_name, args_node);
  575.         gen_i(I_ENTRY_CALL, TYPE_SIZE(entry_name));
  576.         gen_postlude(entry_name, args_node);
  577.         break;
  578.  
  579.     case(as_accept):
  580.         entry_node = N_AST1(node);
  581.         body_node = N_AST3(node);
  582.         id_node = N_AST2(entry_node);
  583.         entry_name    = N_UNQ(id_node);
  584.         gen_value(entry_node);
  585.         gen_ic(I_SELECTIVE_WAIT, 0, "simple accept");
  586.         gen_accept(entry_name, body_node, OPT_NODE);
  587.         break;
  588.  
  589.     /* 9.6 Delay statements, duration and time */
  590.     case(as_delay):
  591.         exp_node = N_AST1(node);
  592.         gen_value(exp_node);
  593.         gen(I_WAIT);
  594.         break;
  595.  
  596.     /* 9.7 Select statements */
  597.     case(as_selective_wait):
  598.         /* Note: Else part added as a delay 0 in alt_list by expander */
  599.         alt_node = N_AST1(node);
  600.         select_list  = N_LIST(alt_node);
  601.  
  602.     case_table  = tup_new(0);
  603.     case_bodies = tup_new(0);
  604.         tag = 0;
  605.         FORTUP(stmt_node=(Node), select_list, ft1);
  606.             tag += 1;
  607.             if (N_KIND(stmt_node) == as_guard) {
  608.                 cond_node = N_AST1(stmt_node);
  609.                 stmt_node = N_AST2(stmt_node);
  610.                 gen_value(cond_node);
  611.                 guarded = TRUE;
  612.             }
  613.             else {
  614.                 gen_kvc(I_PUSH_IMMEDIATE, kind_of(symbol_boolean),
  615.                   int_const(TRUE), "True guard");
  616.                 guarded = FALSE;
  617.             }
  618.  
  619.             if (N_KIND(stmt_node)== as_accept_alt) {
  620.                 acc_node = N_AST1(stmt_node);
  621.                 body_node = N_AST2(stmt_node);
  622.                 entry_node = N_AST1(acc_node);
  623.                 id_node = N_AST2(entry_node);
  624.                 entry_name = N_UNQ(id_node);
  625.  
  626.                 flag = 1;
  627.                 if (guarded) {
  628.                     cond_val = get_ivalue(cond_node);
  629.                     if (cond_val->const_kind!=CONST_OM  ) {
  630.                         if (cond_val->const_value.const_int == ada_bool(TRUE)) {
  631.                             gen_value(entry_node);
  632.                         }
  633.                         else {
  634.                             gen_kvc(I_PUSH_IMMEDIATE, mu_byte, int_const_0,
  635.                               "dummy member");
  636.                             gen_kvc(I_PUSH_IMMEDIATE, mu_word, int_const_0,
  637.                               "dummy family");
  638.                         }
  639.                     }
  640.                     else {
  641.                         gen_k(I_DUPLICATE, kind_of(symbol_boolean));
  642.                         true_guard = new_unique_name("true_guard");
  643.                         gen_s(I_JUMP_IF_TRUE, true_guard);
  644.                         gen_kvc(I_PUSH_IMMEDIATE, mu_byte, int_const_0,
  645.                           "dummy member");
  646.                         gen_kvc(I_PUSH_IMMEDIATE, mu_word, int_const_0,
  647.                           "dummy family");
  648.                         end_alt = new_unique_name("end_alt");
  649.                         gen_s(I_JUMP, end_alt);
  650.                         gen_s(I_LABEL, true_guard);
  651.                         gen_value(entry_node);
  652.                         gen_s(I_LABEL, end_alt);
  653.                     }
  654.                 }
  655.                 else {
  656.                     gen_value(entry_node);
  657.                 }
  658.  
  659.             }
  660.             else if (N_KIND(stmt_node) == as_delay_alt) {
  661.                 delay_node = N_AST1(stmt_node);
  662.                 delay_node = N_AST1(delay_node);
  663.                 flag = 2;
  664.                 if (guarded) {
  665.                     cond_val = get_ivalue(cond_node);
  666.                     if (cond_val->const_kind != CONST_OM  ) {
  667.                         if (cond_val->const_value.const_int == ada_bool(TRUE)) {
  668.                             gen_value(delay_node);
  669.                         }
  670.                         else {
  671.                             gen_kvc(I_PUSH_IMMEDIATE, kind_of(symbol_duration), 
  672.                               int_const_0, "dummy duration");
  673.                         }
  674.                     }
  675.                     else {
  676.                         gen_k(I_DUPLICATE, kind_of(symbol_boolean));
  677.                         true_guard = new_unique_name("true_guard");
  678.                         gen_s(I_JUMP_IF_TRUE, true_guard);
  679.                         gen_kvc(I_PUSH_IMMEDIATE, kind_of(symbol_duration), 
  680.                           int_const_0, "dummy duration");
  681.                         end_alt = new_unique_name("end_alt");
  682.                         gen_s(I_JUMP, end_alt);
  683.                         gen_s(I_LABEL, true_guard);
  684.                         gen_value(delay_node);
  685.                         gen_s(I_LABEL, end_alt);
  686.                     }
  687.                 }
  688.                 else {
  689.                     gen_value(delay_node);
  690.                 }
  691.  
  692.             }
  693.             else if (N_KIND(stmt_node) == as_terminate_alt) {
  694.                 flag = 3;
  695.             }
  696.  
  697.             gen_kv(I_PUSH_IMMEDIATE, mu_byte, int_const(flag));
  698.             tup = tup_new(2);
  699.             tup[1] = (char *) tag;
  700.             tup[2] = (char *) tag;
  701.             case_table  =tup_with(case_table, (char *)tup);
  702.             case_bodies = tup_with(case_bodies, (char *) stmt_node);
  703.  
  704.         ENDFORTUP(ft1);
  705.  
  706.         gen_i(I_SELECTIVE_WAIT, tup_size(select_list));
  707.  
  708.         gen_case(case_table, case_bodies, OPT_NODE, mu_byte);
  709.         break;
  710.  
  711.     case(as_accept_alt):
  712.         acc_node = N_AST1(node) ;
  713.         stmts_node   = N_AST2(node) ;
  714.         entry_node = N_AST1(acc_node);
  715.         body_node = N_AST3(acc_node);
  716.         id_node            = N_AST2(entry_node);
  717.         entry_name               = N_UNQ(id_node);
  718.         gen_accept(entry_name, body_node, stmts_node);
  719.         break;
  720.  
  721.     case(as_delay_alt):
  722.         body_node = N_AST2(node);
  723.         compile(body_node);
  724.         break;
  725.  
  726.     case(as_terminate_alt):
  727.         nesting_depth = (int) N_VAL(node);
  728.         for (i = 1; i <= nesting_depth; i++)
  729.             gen(I_LEAVE_BLOCK);
  730.         gen_ic(I_TERMINATE, 1, "terminate alternative");
  731.         break;
  732.  
  733.     case(as_timed_entry_call):
  734.         /* note: this case includes also conditional entry call */
  735.         call_node = N_AST1(node);
  736.         stmts1_node = N_AST2(node);
  737.         delay_node = N_AST3(node);
  738.         entry_node = N_AST1(call_node);
  739.         args_node              = N_AST2(call_node);
  740.         id_node                        = N_AST2(entry_node);
  741.         entry_name                           = N_UNQ(id_node);
  742.         temp_node = delay_node;
  743.         delay_node = N_AST1(temp_node);
  744.         stmts2_node            = N_AST2(temp_node);
  745.         delay_node                         = N_AST1(delay_node);
  746.  
  747.         gen_value(entry_node);
  748.         gen_prelude(entry_name, args_node);
  749.         gen_value(delay_node);
  750.         gen_i(I_TIMED_ENTRY_CALL, TYPE_SIZE(entry_name));
  751.  
  752.         else_part = new_unique_name("else");
  753.         gen_s(I_JUMP_IF_FALSE, else_part);
  754.         gen_postlude(entry_name, args_node);
  755.         compile(stmts1_node);   /* rendezvous occured */
  756.         if (stmts2_node != OPT_NODE) {
  757.             end_if = new_unique_name("end_if");
  758.             gen_s(I_JUMP, end_if);
  759.             gen_s(I_LABEL, else_part);
  760.             compile(stmts2_node); /* rendezvous did not occur */
  761.             gen_s(I_LABEL, end_if);
  762.         }
  763.         else {
  764.             gen_s(I_LABEL, else_part);
  765.         }
  766.         break;
  767.  
  768.     /*
  769.      *---------------
  770.      * 9.8 Priorities
  771.      *
  772.      *(as_priority):
  773.      *   pass;
  774.  
  775.      *---------------------
  776.      * 9.9 Abort statements
  777.      */
  778.     case(as_abort):
  779.         task_list = N_LIST(node);
  780.         FORTUP(task_node=(Node), task_list, ft1);
  781.             gen_value(task_node);
  782.         ENDFORTUP(ft1);
  783.         gen_i(I_ABORT, tup_size(task_list));
  784.         break;
  785.  
  786.     /* Chapter 10. Program structure and compilation issues
  787.      *------------------------------------
  788.      * 10.2 Subunits of compilations units
  789.      */
  790.     case(as_subprogram_stub_tr):
  791.         /* Generate spec if not already done: */
  792.         proc_name   = N_UNQ(node);
  793.  
  794.         /* Avoid processing generic subprogram stubs */
  795.         if (NATURE(proc_name) == na_generic_procedure 
  796.           || NATURE(proc_name) == na_generic_function) {
  797.         }
  798.         else {
  799.             if (assoc_symbol_exists(proc_name, PROC_TEMPLATE)) {
  800.                 if (!is_defined(assoc_symbol_get(proc_name, PROC_TEMPLATE)))
  801.                     gen_subprogram_spec(node);
  802.             }
  803.             else {
  804.                 gen_subprogram_spec(node);
  805.             }
  806.             gen_stub(node);
  807.         }
  808.         break;
  809.  
  810.     case(as_package_stub): 
  811.     case(as_task_stub):
  812.         gen_stub(node);
  813.         break;
  814.  
  815.     case(as_separate):
  816.         separate_unit_node = N_AST2(node);
  817.         compile(separate_unit_node);
  818.         break;
  819.  
  820.     /* Chapter 11. Exceptions
  821.      *----------------------------
  822.      * 11.1 Exception declarations
  823.      */
  824.     case(as_except_decl):
  825.         except_names = tup_new(0);
  826.         FORTUP(id_node=(Node), N_LIST(node), ft1);
  827.             if (!tup_mem((char *)N_UNQ(id_node), except_names))
  828.                 except_names = tup_with(except_names, (char *) N_UNQ(id_node));
  829.         ENDFORTUP(ft1);
  830.         FORTUP(exception_name=(Symbol), except_names, ft1);
  831.             select_entry(SELECT_EXCEPTIONS, exception_name, SLOTS_EXCEPTION);
  832.         ENDFORTUP(ft1);
  833.         tup_free(except_names);
  834.         break;
  835.  
  836.     /* 11.3 Raise statements */
  837.     case(as_raise):
  838.         id_node = N_AST1(node);
  839.         if (id_node != OPT_NODE)
  840.             gen_s(I_LOAD_EXCEPTION_REGISTER, N_UNQ(id_node));
  841.         gen(I_RAISE);
  842.         break;
  843.  
  844.     /* 11.5 Exceptions raised during task communication */
  845.     case(as_exception_accept):
  846.         gen(I_RAISE_IN_CALLER);
  847.         gen(I_END_RENDEZVOUS);
  848.         gen(I_RAISE);
  849.         break;
  850.  
  851.     /* Chapter 12. Generics units */
  852.     case(as_generic_function): 
  853.     case(as_generic_procedure):
  854.     case(as_generic_package):
  855.         break;
  856.  
  857.     case(as_null):
  858. #ifdef DEBUG
  859.         printf("compile for node kind as_null - skipped\n");
  860. #endif
  861.         break;
  862.  
  863.     /*--------------------------------------------------- */
  864.     default:
  865. #ifdef DEBUG
  866.         zpnod(node);/* for initial debug - dump node */
  867.         compiler_error_k("Unknown kind of node in compile: ", node );
  868. #endif
  869.         chaos("unknown node kind in compile");
  870.     }
  871. }
  872.  
  873. static void compile_line()                                    /*;compile_line*/
  874. {
  875.     /* called when starting to compile line debug_line, used for debugging */
  876. }
  877.